home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir44 / dungn32.zip / SUBR.FOR < prev    next >
Text File  |  1994-10-08  |  39KB  |  1,264 lines
  1. C Subroutines for DUNGEON
  2. C
  3. C COPYRIGHT 1980, 1990, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA.
  4. C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  5. C WRITTEN BY R. M. SUPNIK
  6. C
  7. C 27-Sep-94     RMS     Fixed bugs in WEIGHR, JIGSUP, SCORE.
  8. C                       Added GRANITE WALL to GHERE.
  9. C 30-Jan-94     RMS     Fixed bugs from MS DOS port.
  10. C 30-Jun-92     RMS     Changed file names to lower case.
  11. C 29-Jun-92     RMS     Removed extraneous declaration in RMDESC.
  12. C
  13. C RSPEAK-- Output random message routine
  14. C
  15. C Called by--
  16. C
  17. C       CALL RSPEAK(MSGNUM)
  18. C
  19.       SUBROUTINE RSPEAK(N)
  20.       IMPLICIT INTEGER (A-Z)
  21. C
  22.       CALL RSPSB2(N,0,0)
  23.       RETURN
  24. C
  25.       END
  26. C
  27. C RSPSUB-- Output random message with substitutable argument
  28. C
  29. C Called by--
  30. C
  31. C       CALL RSPSUB(MSGNUM,SUBNUM)
  32. C
  33.       SUBROUTINE RSPSUB(N,S1)
  34.       IMPLICIT INTEGER (A-Z)
  35. C
  36.       CALL RSPSB2(N,S1,0)
  37.       RETURN
  38. C
  39.       END
  40.  
  41. C RSPSB2-- Output random message with substitutable arguments
  42. C
  43. C Called by--
  44. C
  45. C       CALL RSPSB2(MSGNUM,S1,S2)
  46. C
  47.       SUBROUTINE RSPSB2(A,B,C)
  48.       IMPLICIT INTEGER (A-Z)
  49.       INCLUDE 'dparam.for'
  50.       CHARACTER*(TEXLNT) B1,B2
  51. C
  52. C Convert all arguments from dictionary numbers (if positive)
  53. c to absolute record numbers.
  54. C
  55.       X=A                                       ! set up work variables.
  56.       Y=B
  57.       Z=C
  58.       IF(X.GT.0) X=RTEXT(X)                     ! if >0, look up in rtext.
  59.       IF(Y.GT.0) Y=RTEXT(Y)
  60.       IF(Z.GT.0) Z=RTEXT(Z)
  61.       X=IABS(X)                                 ! take abs value.
  62.       Y=IABS(Y)
  63.       Z=IABS(Z)
  64.       IF(X.EQ.0) RETURN                         ! anything to do?
  65.       TELFLG=.TRUE.                             ! said something.
  66. C
  67.       READ(DBCH,REC=X) OLDREC,B1                ! read first line.
  68. 100   CALL TXCRYP(X,B1)                         ! decrypt line.
  69. C
  70. 200   IF(Y.EQ.0) GO TO 400                      ! any substitutable?
  71.       I=INDEX(B1,'#')                           ! look for #.
  72.       IF(I.GT.0) GO TO 1000                     ! found?
  73. C
  74. 400   WRITE(OUTCH,650) B1(1:MAX0(1,NBLEN(B1)))! output line.
  75. 650   FORMAT(1X,A)
  76.       X=X+1                                     ! on to next record.
  77.       READ(DBCH,REC=X) NEWREC,B1                ! read next record.
  78.       IF(OLDREC.EQ.NEWREC) GO TO 100            ! continuation?
  79.       RETURN                                    ! no, exit.
  80.  
  81. C RSPSB2, PAGE 2
  82. C
  83. C Substitution with substitutable available.
  84. C I is index of # in B1.
  85. C Y is number of record to substitute.
  86. C
  87. C Procedure:
  88. C   1) Copy rest of B1 to B2
  89. C   2) Read substitutable over B1
  90. C   3) Restore tail of original B1
  91. C
  92. C The implicit assumption here is that the substitutable string
  93. c is very short.
  94. C
  95. 1000  B2(1:(TEXLNT-I))=B1(I+1:TEXLNT)           ! copy rest of B1.
  96. C
  97.       READ(DBCH,REC=Y) J,B1(I:TEXLNT)           ! read sub record.
  98.       CALL TXCRYP(Y,B1(I:TEXLNT))               ! decrypt sub record.
  99.       J=NBLEN(B1)                               ! backscan for blanks.
  100.       B1(J+1:TEXLNT)=B2(1:TEXLNT-J)
  101. C
  102.       Y=Z                                       ! set up for next
  103.       Z=0                                       ! substitution and
  104.       GO TO 200                                 ! recheck line.
  105. C
  106.       END
  107.  
  108. C OBJACT-- Apply objects from parse vector
  109. C
  110. C Declarations
  111. C
  112.       LOGICAL FUNCTION OBJACT(X)
  113.       IMPLICIT INTEGER (A-Z)
  114.       INCLUDE 'dparam.for'
  115.       LOGICAL OAPPLI
  116. C
  117.       OBJACT=.TRUE.                             ! assume wins.
  118.       IF(PRSI.EQ.0) GO TO 100                   ! ind object?
  119.       IF(OAPPLI(OACTIO(PRSI),0)) RETURN         ! yes, let it handle.
  120. C
  121. 100   IF(PRSO.EQ.0) GO TO 200                   ! dir object?
  122.       IF(OAPPLI(OACTIO(PRSO),0)) RETURN         ! yes, let it handle.
  123. C
  124. 200   OBJACT=.FALSE.                            ! loses.
  125.       RETURN
  126. C
  127.       END
  128.  
  129. C BUG-- Report fatal system error
  130. C
  131. C Declarations
  132. C
  133.       SUBROUTINE BUG(A,B)
  134.       IMPLICIT INTEGER (A-Z)
  135.       INCLUDE 'dparam.for'
  136. C
  137.       WRITE(OUTCH,100) A,B                      ! gonzo
  138.       IF(DBGFLG.NE.0) RETURN
  139.       SUBBUF='CRASH.DAT'                        ! set up crash save name.
  140.       SUBLNT=NBLEN(SUBBUF)
  141.       CALL SAVEGM                               ! do final save.
  142.       WRITE(OUTCH,200)
  143.       STOP ' '
  144. C
  145. 100   FORMAT(' Program error ',I2,', parameter =',I6)
  146. 200   FORMAT(' Game state saved in "CRASH.DAT".')
  147. C
  148.       END
  149.  
  150. C NEWSTA-- Set new status for object
  151. C
  152. C Called by--
  153. C
  154. C       CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV)
  155. C
  156.       SUBROUTINE NEWSTA(O,R,RM,CN,AD)
  157.       IMPLICIT INTEGER (A-Z)
  158.       INCLUDE 'dparam.for'
  159. C
  160.       CALL RSPEAK(R)
  161.       OROOM(O)=RM
  162.       OCAN(O)=CN
  163.       OADV(O)=AD
  164.       RETURN
  165. C
  166.       END
  167.  
  168. C QHERE-- Test for object in room
  169. C
  170. C Declarations
  171. C
  172.       LOGICAL FUNCTION QHERE(OBJ,RM)
  173.       IMPLICIT INTEGER (A-Z)
  174.       INCLUDE 'dparam.for'
  175. C
  176.       QHERE=.TRUE.
  177.       IF(OROOM(OBJ).EQ.RM) RETURN               ! in room?
  178.       DO 100 I=1,R2LNT                          ! no, sch room2.
  179.         IF((O2(I).EQ.OBJ).AND.(R2(I).EQ.RM)) RETURN
  180. 100   CONTINUE
  181.       QHERE=.FALSE.                             ! not present.
  182.       RETURN
  183. C
  184.       END
  185.  
  186. C QEMPTY-- Test for object empty
  187. C
  188. C Declarations
  189. C
  190.       LOGICAL FUNCTION QEMPTY(OBJ)
  191.       IMPLICIT INTEGER (A-Z)
  192.       INCLUDE 'dparam.for'
  193. C
  194.       QEMPTY=.FALSE.                            ! assume lose.
  195.       DO 100 I=1,OLNT
  196.         IF(OCAN(I).EQ.OBJ) RETURN               ! inside target?
  197. 100   CONTINUE
  198.       QEMPTY=.TRUE.
  199.       RETURN
  200. C
  201.       END
  202.  
  203. C JIGSUP- You are dead
  204. C
  205. C Declarations
  206. C
  207.       SUBROUTINE JIGSUP(DESC)
  208.       IMPLICIT INTEGER (A-Z)
  209.       INCLUDE 'dparam.for'
  210.       LOGICAL MOVETO,QHERE,F
  211.       INTEGER RLIST(8)
  212. C
  213. C Functions and data
  214. C
  215.       DATA RLIST/KITCH,CLEAR,FORE3,FORE2,SHOUS,FORE2,KITCH,EHOUS/
  216. C
  217.       CALL RSPEAK(DESC)                         ! describe sad state.
  218.       PRSCON=0                                  ! stop parser.
  219.       IF(DBGFLG.NE.0) RETURN                    ! if dbg, exit.
  220.       AVEHIC(WINNER)=0                          ! get rid of vehicle.
  221.       IF(WINNER.EQ.PLAYER) GO TO 10             ! himself?
  222.       CALL RSPSUB(432,ODESC2(AOBJ(WINNER)))     ! no, say who died.
  223.       CALL NEWSTA(AOBJ(WINNER),0,0,0,0)         ! send object to hyper space.
  224.       AROOM(WINNER)=0                           ! send actor to hyper space.
  225.       RETURN
  226. C
  227. 10    CALL SCRUPD(-10)                          ! charge 10 points.
  228.       IF(ENDGMF) GO TO 900                      ! no recovery in end game.
  229.       IF(DEATHS.GE.2) GO TO 1000                ! dead twice? kick him off.
  230.       DEATHS=DEATHS+1                           ! record deaths.
  231.       DEADF=.TRUE.                              ! flag dead player.
  232.       I=8                                       ! normal message.
  233.       IF(LLDF) I=1074                           ! ghosts exorcised?
  234.       CALL RSPEAK(I)                            ! tell him bad news.
  235.       AACTIO(PLAYER)=PLAYER                     ! turn on dead player func.
  236. C
  237.       DO 50 J=1,OLNT                            ! turn off fighting.
  238.         IF(QHERE(J,HERE)) OFLAG2(J)=OFLAG2(J).AND. .NOT.FITEBT
  239. 50    CONTINUE
  240. C
  241.       F=MOVETO(LLD1,WINNER)                     ! reposition him.
  242.       EGYPTF=.TRUE.                             ! restore coffin.
  243.       IF(OADV(COFFI).EQ.WINNER) CALL NEWSTA(COFFI,0,EGYPT,0,0)
  244.       OFLAG2(DOOR)=OFLAG2(DOOR).AND. .NOT.TCHBT ! restore door.
  245.       OFLAG1(ROBOT)=(OFLAG1(ROBOT).OR.VISIBT) .AND. .NOT.NDSCBT
  246.       CALL NEWSTA(LAMP,0,LROOM,0,0)             ! lamp to living room,
  247.       OFLAG1(LAMP)=OFLAG1(LAMP).OR.VISIBT       ! visible
  248.       DO 100 I=1,CLNT                           ! disable cevnts if needed.
  249.         IF(CCNCEL(I)) CFLAG(I)=.FALSE.
  250. 100   CONTINUE
  251.  
  252. C JIGSUP, PAGE 2
  253. C
  254. C Now redistribute his valuables and other belongings.
  255. C
  256. C The lamp has been placed in the living room.
  257. C The first 8 non-valuables are placed in locations around the house.
  258. C His valuables are placed starting at Troll Room.
  259. C Remaining non-valuables are after that.
  260. C
  261.       I=0
  262.       DO 200 J=1,OLNT                           ! loop thru objects.
  263.         IF((OADV(J).NE.WINNER).OR.(OTVAL(J).NE.0))
  264.      1GO TO 200                                 ! get his non-val objs.
  265.         I=I+1
  266.         IF(I.GT.8) GO TO 400                    ! move to random locations.
  267.         CALL NEWSTA(J,0,RLIST(I),0,0)
  268. 200   CONTINUE
  269. C
  270. 400   I=MTROL                                   ! now move valuables.
  271.       NONOFL=RAIR+RWATER+REND                   ! dont move here.
  272.       DO 300 J=1,OLNT
  273.         IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0))
  274.      1GO TO 300                                 ! on adv and valuable?
  275. 250     I=I+1                                   ! find next room.
  276.         IF((RFLAG(I).AND.NONOFL).NE.0) GO TO 250 ! skip if nono.
  277.         CALL NEWSTA(J,0,I,0,0)                  ! yes, move.
  278. 300   CONTINUE
  279. C
  280.       DO 500 J=1,OLNT                           ! now get rid of remainder.
  281.         IF(OADV(J).NE.WINNER) GO TO 500
  282. 450     I=I+1                                   ! find next room.
  283.         IF((RFLAG(I).AND.NONOFL).NE.0) GO TO 450 ! skip if nono.
  284.         CALL NEWSTA(J,0,I,0,0)
  285. 500   CONTINUE
  286.       RETURN
  287. C
  288. C Cant or wont continue, clean up and exit.
  289. C
  290. 900   CALL RSPEAK(625)                          ! in endgame, lose.
  291.       GO TO 1100
  292. C
  293. 1000  CALL RSPEAK(7)                            ! involuntary exit.
  294. 1100  CALL SCORE(.FALSE.)                       ! tell score.
  295.       STOP ' '
  296. C
  297.       END
  298.  
  299. C OACTOR-       Get actor associated with object
  300. C
  301. C Declarations
  302. C
  303.       INTEGER FUNCTION OACTOR(OBJ)
  304.       IMPLICIT INTEGER (A-Z)
  305.       INCLUDE 'dparam.for'
  306. C
  307.       DO 100 OACTOR=1,ALNT                      ! loop thru actors.
  308.         IF(AOBJ(OACTOR).EQ.OBJ) RETURN          ! found it?
  309. 100   CONTINUE
  310.       CALL BUG(40,OBJ)                          ! no, die.
  311.       RETURN
  312. C
  313.       END
  314.  
  315. C PROB-         Compute probability
  316. C
  317. C Declarations
  318. C
  319.       LOGICAL FUNCTION PROB(G,B)
  320.       IMPLICIT INTEGER (A-Z)
  321.       INCLUDE 'dparam.for'
  322. C
  323.       I=G                                       ! assume good luck.
  324.       IF(BADLKF) I=B                            ! if bad, too bad.
  325.       PROB=RND(100).LT.I                        ! compute.
  326.       RETURN
  327. C
  328.       END
  329.  
  330. C RMDESC-- Print room description
  331. C
  332. C RMDESC prints a description of the current room.
  333. C It is also the processor for verbs 'LOOK' and 'EXAMINE'
  334. C when there is no direct object.
  335. C
  336.       LOGICAL FUNCTION RMDESC(FULL)
  337. C
  338. C FULL= 0/1/2/3=        full/obj/room/full but no applicable
  339. C
  340. C Declarations
  341. C
  342.       IMPLICIT INTEGER (A-Z)
  343.       LOGICAL PROB,LIT
  344.       INCLUDE 'dparam.for'
  345. C
  346.       RMDESC=.TRUE.                             ! assume wins.
  347.       RA=RACTIO(HERE)                           ! get room action.
  348.       IF(PRSO.LT.XMIN) GO TO 50                 ! if direction,
  349.       FROMDR=PRSO                               ! save and
  350.       PRSO=0                                    ! clear.
  351. 50    IF(FULL.EQ.1) GO TO 600                   ! objects only?
  352.       IF(HERE.EQ.AROOM(PLAYER)) GO TO 100       ! player just move?
  353.       CALL RSPEAK(2)                            ! no, just say done.
  354.       PRSA=WALKIW                               ! set up walk in action.
  355.       RETURN
  356. C
  357. 100   IF(LIT(HERE)) GO TO 300                   ! lit?
  358.       CALL RSPEAK(430)                          ! warn of grue.
  359.       RMDESC=.FALSE.
  360.       RETURN
  361. C
  362. 300   I=RDESC2-HERE                             ! assume short desc.
  363.       IF((FULL.EQ.0)
  364.      1.AND. (SUPERF.OR.(((RFLAG(HERE).AND.RSEEN).NE.0)
  365.      1.AND. (BRIEFF.OR.PROB(80,80))))) GO TO 400
  366.       I=RDESC1(HERE)                            ! use long.
  367.       IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400       ! if got desc, skip.
  368.       PRSA=LOOKW                                ! pretend look around.
  369.       PRSO=0                                    ! no object referenced.
  370.       CALL RAPPLI(RA)                           ! let room handle.
  371.       PRSA=FOOW                                 ! nop parser.
  372.       GO TO 500
  373. C
  374. 400   CALL RSPEAK(I)                            ! output description.
  375. 500   IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER)))
  376.       RFLAG(HERE)=RFLAG(HERE).OR.RSEEN          ! indicate room seen.
  377. C
  378. 600   IF(LIT(HERE)) GO TO 700                   ! if lit, do objects
  379.       CALL RSPEAK(1036)                         ! can't see anything
  380.       RETURN
  381. C
  382. 700   IF(FULL.NE.2) CALL PRINCR(FULL,HERE)      ! print room contents
  383.       IF((FULL.NE.0).OR.(RA.EQ.0)) RETURN       ! anything more?
  384.       PRSA=WALKIW                               ! give him a surpise.
  385.       CALL RAPPLI(RA)                           ! let room handle
  386.       PRSA=FOOW
  387.       RETURN
  388. C
  389.       END
  390.  
  391. C PRINCR- Print contents of room
  392. C
  393. C Declarations
  394. C
  395.       SUBROUTINE PRINCR(FULL,RM)
  396.       IMPLICIT INTEGER (A-Z)
  397.       INCLUDE 'dparam.for'
  398.       LOGICAL QEMPTY,QHERE
  399. C
  400.       J=329                                     ! assume superbrief format.
  401.       DO 500 I=1,OLNT                           ! loop on objects
  402.         IF(.NOT.QHERE(I,RM).OR.((OFLAG1(I).AND.VISIBT).EQ.0).OR.
  403.      1(((OFLAG1(I).AND.NDSCBT).NE.0).AND.(FULL.NE.1)).OR.
  404.      2(I.EQ.AVEHIC(WINNER))) GO TO 500
  405.         IF((FULL.EQ.0).AND.(SUPERF.OR.(BRIEFF.AND.
  406.      1((RFLAG(HERE).AND.RSEEN).NE.0)))) GO TO 200
  407. C
  408. C Do long description of object.
  409. C
  410.         K=ODESCO(I)                             ! get untouched.
  411.         IF((K.EQ.0).OR.((OFLAG2(I).AND.TCHBT).NE.0)) K=ODESC1(I)
  412.         IF((K.EQ.0).AND.(FULL.EQ.1)) CALL RSPSUB(936,ODESC2(I))
  413.         CALL RSPEAK(K)                          ! describe.
  414.         GO TO 500
  415. C
  416. C Do short description of object.
  417. C
  418. 200     CALL RSPSUB(J,ODESC2(I))                ! you can see it.
  419.         J=502
  420. C
  421. 500   CONTINUE
  422. C
  423. C Now loop to print contents of objects in room.
  424. C
  425.       DO 1000 I=1,OLNT                          ! loop on objects.
  426.         IF(.NOT.QHERE(I,RM).OR.((OFLAG1(I).AND.VISIBT).EQ.0).OR.
  427.      1(((OFLAG1(I).AND.NDSCBT).NE.0).AND.(FULL.NE.1)))
  428.      2GO TO 1000
  429.         IF((OFLAG2(I).AND.ACTRBT).NE.0) CALL INVENT(OACTOR(I))
  430.         IF((((OFLAG1(I).AND.TRANBT).EQ.0).AND.((OFLAG2(I).AND.OPENBT)
  431.      1.EQ.0)).OR.QEMPTY(I)) GO TO 1000
  432. C
  433. C Object is not empty and is open or transparent.
  434. C
  435.         IF(I.NE.TCASE) GO TO 600                ! trophy case?
  436.         IF((.NOT.(BRIEFF.OR.SUPERF)).OR.(FULL.EQ.1))
  437.      1CALL PRINCO(I,1053,.FALSE.)               ! print contents.
  438.         GO TO 1000
  439. 600     CALL PRINCO(I,573,.TRUE.)               ! print contents
  440. 1000  CONTINUE
  441.       RETURN
  442. C
  443.       END
  444.  
  445. C INVENT- Print contents of adventurer
  446. C
  447. C Declarations
  448. C
  449.       SUBROUTINE INVENT(ADV)
  450.       IMPLICIT INTEGER (A-Z)
  451.       INCLUDE 'dparam.for'
  452.       LOGICAL QEMPTY
  453. C
  454.       I=575                                     ! first line.
  455.       IF(ADV.NE.PLAYER) I=576                   ! if not me.
  456.       DO 10 J=1,OLNT                            ! loop
  457.         IF((OADV(J).NE.ADV).OR.((OFLAG1(J).AND.VISIBT).EQ.0))
  458.      1GO TO 10
  459.         CALL RSPSUB(I,ODESC2(AOBJ(ADV)))
  460.         I=0
  461.         CALL RSPSUB(502,ODESC2(J))
  462. 10    CONTINUE
  463. C
  464.       IF(I.EQ.0) GO TO 25                       ! any objects?
  465.       IF(ADV.EQ.PLAYER) CALL RSPEAK(578)        ! no, tell him.
  466.       RETURN
  467. C
  468. 25    DO 100 J=1,OLNT                           ! loop.
  469.         IF((OADV(J).NE.ADV).OR.((OFLAG1(J).AND.VISIBT).EQ.0).OR.
  470.      1(((OFLAG1(J).AND.TRANBT).EQ.0).AND.
  471.      2((OFLAG2(J).AND.OPENBT).EQ.0))) GO TO 100
  472.         IF(.NOT.QEMPTY(J)) CALL PRINCO(J,573,.TRUE.) ! if not empty, list.
  473. 100   CONTINUE
  474.       RETURN
  475. C
  476.       END
  477.  
  478. C PRINCO-       Print contents of object
  479. C
  480. C Declarations
  481. C
  482.       SUBROUTINE PRINCO(OBJ,DESC,LDESCF)
  483.       IMPLICIT INTEGER (A-Z)
  484.       INCLUDE 'dparam.for'
  485.       LOGICAL QEMPTY,LDESCF,MOREF,QSEEIN,QUAL
  486. C
  487. C Functions and data
  488. C
  489.       QSEEIN(X)=((OFLAG1(X).AND.TRANBT).NE.0).OR.
  490.      1  ((OFLAG2(X).AND.OPENBT).NE.0)
  491.       QUAL(X,Y)=((OFLAG1(X).AND.VISIBT).NE.0).AND.
  492.      1   (OCAN(X).EQ.Y).AND.(X.NE.AOBJ(WINNER))
  493. C
  494.       MOREF=.FALSE.                             ! no additional printouts.
  495.       ALSO=0                                    ! no untouched descriptions.
  496.       IF(SUPERF.OR..NOT.LDESCF) GO TO 2000      ! skip long descriptions?
  497.       DO 1000 I=1,OLNT                          ! loop thru objects.
  498.         IF(.NOT.QUAL(I,OBJ)) GO TO 1000         ! inside target?
  499.         IF((ODESCO(I).EQ.0).OR.
  500.      1  ((OFLAG2(I).AND.TCHBT).NE.0)) GO TO 700
  501.         CALL RSPEAK(ODESCO(I))                  ! print untouched descr.
  502.         ALSO=1                                  ! flag.
  503.         IF(.NOT.QSEEIN(I).OR.QEMPTY(I)) GO TO 1000
  504.         CALL RSPSUB(573,ODESC2(I))              ! object, which contains:
  505.         DO 500 J=1,OLNT                         ! loop thru objects.
  506.           IF(QUAL(J,I)) CALL RSPSUB(502,ODESC2(J))
  507. 500     CONTINUE
  508.         GO TO 1000
  509. 700     MOREF=.TRUE.
  510. 1000  CONTINUE
  511.       IF(.NOT.MOREF) RETURN                     ! more to do?
  512. C
  513. 2000  CALL RSPSUB(DESC+ALSO,ODESC2(OBJ))        ! print header.
  514.       DO 3000 I=1,OLNT                          ! loop thru objects.
  515.         IF(.NOT.QUAL(I,OBJ)) GO TO 3000         ! inside target?
  516.         IF((ALSO.NE.0).AND.(ODESCO(I).NE.0).AND.
  517.      1   ((OFLAG2(I).AND.TCHBT).EQ.0)) GO TO 3000
  518.         IF(.NOT.QSEEIN(I).OR.QEMPTY(I)) GO TO 2700
  519.         CALL RSPSUB(1050,ODESC2(I))             ! object, which contains:
  520.         DO 2500 J=1,OLNT                        ! loop thru objects.
  521.           IF(QUAL(J,I)) CALL RSPSUB(1051,ODESC2(J))
  522. 2500    CONTINUE
  523.         GO TO 3000
  524. 2700    CALL RSPSUB(502,ODESC2(I))              ! object, nothing inside.
  525. 3000  CONTINUE
  526.       RETURN
  527. C
  528.       END
  529.  
  530. C MOVETO- Move player to new room
  531. C
  532. C Declarations
  533. C
  534.       LOGICAL FUNCTION MOVETO(NR,WHO)
  535.       IMPLICIT INTEGER (A-Z)
  536.       INCLUDE 'dparam.for'
  537.       LOGICAL NLV,LHR,LNR
  538. C
  539.       MOVETO=.FALSE.                            ! assume fails.
  540.       LHR=(RFLAG(HERE).AND.RLAND).NE.0          ! land  here flag.
  541.       LNR=(RFLAG(NR).AND.RLAND).NE.0            ! land there flag.
  542.       J=AVEHIC(WHO)                             ! his vehicle
  543. C
  544.       IF(J.NE.0) GO TO 100                      ! in vehicle?
  545.       IF(LNR) GO TO 500                         ! no, going to land?
  546.       CALL RSPEAK(427)                          ! can't go without vehicle.
  547.       RETURN
  548. C
  549. 100   BITS=0                                    ! assume nowhere.
  550.       IF(J.EQ.RBOAT) BITS=RWATER                ! in boat?
  551.       IF(J.EQ.BALLO) BITS=RAIR                  ! in balloon?
  552.       IF(J.EQ.BUCKE) BITS=RBUCK                 ! in bucket?
  553.       NLV=(RFLAG(NR).AND.BITS).EQ.0             ! got wrong vehicle flag.
  554.       IF((.NOT.LNR .AND.NLV) .OR.
  555.      1(LNR.AND.LHR.AND.NLV.AND.(BITS.NE.RLAND)))
  556.      2GO TO 800                                 ! got wrong vehicle?
  557. C
  558. 500   MOVETO=.TRUE.                             ! move should succeed.
  559.       IF((RFLAG(NR).AND.RMUNG).EQ.0) GO TO 600  ! room munged?
  560.       CALL RSPEAK(RDESC1(NR))                   ! yes, tell how.
  561.       RETURN
  562. C
  563. 600   IF(WHO.NE.PLAYER) CALL NEWSTA(AOBJ(WHO),0,NR,0,0)
  564.       IF(J.NE.0) CALL NEWSTA(J,0,NR,0,0)
  565.       HERE=NR
  566.       AROOM(WHO)=HERE
  567.       CALL SCRUPD(RVAL(NR))                     ! score room
  568.       RVAL(NR)=0
  569.       RETURN
  570. C
  571. 800   CALL RSPSUB(428,ODESC2(J))                ! wrong vehicle.
  572.       RETURN
  573. C
  574.       END
  575.  
  576. C SCORE-- Print out current score
  577. C
  578. C Declarations
  579. C
  580.       SUBROUTINE SCORE(FLG)
  581.       IMPLICIT INTEGER (A-Z)
  582.       INCLUDE 'dparam.for'
  583.       LOGICAL FLG
  584.       INTEGER RANK(10),ERANK(5)
  585. C
  586. C Functions and data
  587. C
  588.       DATA RANK/20,19,18,16,12,8,4,2,1,0/
  589.       DATA ERANK/20,15,10,5,0/
  590. C
  591.       AS=ASCORE(WINNER)
  592.       IF(ENDGMF) GO TO 60                       ! endgame?
  593.       IF(FLG) WRITE(OUTCH,100)
  594.       IF(.NOT.FLG) WRITE(OUTCH,110)
  595.       IF(MOVES.NE.1) WRITE(OUTCH,120) AS,MXSCOR,MOVES
  596.       IF(MOVES.EQ.1) WRITE(OUTCH,130) AS,MXSCOR,MOVES
  597.       IF(AS.LT.0) GO TO 50                      ! negative score?
  598.       DO 10 I=1,10                              ! find rank.
  599.         IF((AS*20/MXSCOR).GE.RANK(I)) GO TO 20
  600. 10    CONTINUE
  601.       I=10                                      ! beginner.
  602. 20    CALL RSPEAK(484+I)                        ! print rank.
  603.       RETURN
  604. C
  605. 50    CALL RSPEAK(886)                          ! negative score.
  606.       RETURN
  607. C
  608. 60    IF(FLG) WRITE(OUTCH,140)
  609.       IF(.NOT.FLG) WRITE(OUTCH,150)
  610.       WRITE(OUTCH,120) EGSCOR,EGMXSC,MOVES
  611.       DO 70 I=1,5
  612.         IF((EGSCOR*20/EGMXSC).GE.ERANK(I)) GO TO 80
  613. 70    CONTINUE
  614.       I=5                                       ! beginner.
  615. 80    CALL RSPEAK(786+I)
  616.       RETURN
  617. C
  618. 100   FORMAT(' Your score would be',$)
  619. 110   FORMAT(' Your score is',$)
  620. 120   FORMAT('+',I4,' [total of',I4,' points], in',I5,' moves.')
  621. 130   FORMAT('+',I4,' [total of',I4,' points], in',I5,' move.')
  622. 140   FORMAT(' Your score in the endgame would be',$)
  623. 150   FORMAT(' Your score in the endgame is',$)
  624. C
  625.       END
  626.  
  627. C SCRUPD- Update winner's score
  628. C
  629. C Declarations
  630. C
  631.       SUBROUTINE SCRUPD(N)
  632.       IMPLICIT INTEGER (A-Z)
  633.       INCLUDE 'dparam.for'
  634. C
  635.       IF(ENDGMF) GO TO 100                      ! endgame?
  636.       ASCORE(WINNER)=ASCORE(WINNER)+N           ! update score
  637.       RWSCOR=RWSCOR+N                           ! update raw score
  638.       IF(ASCORE(WINNER).LT.(MXSCOR-(10*MIN0(1,DEATHS)))) RETURN
  639.       CFLAG(CEVEGH)=.TRUE.                      ! turn on end game
  640.       CTICK(CEVEGH)=15
  641.       RETURN
  642. C
  643. 100   EGSCOR=EGSCOR+N                           ! update eg score.
  644.       RETURN
  645. C
  646.       END
  647.  
  648. C FINDXT- Find exit from room
  649. C
  650. C Declarations
  651. C
  652.       LOGICAL FUNCTION FINDXT(DIR,RM)
  653.       IMPLICIT INTEGER (A-Z)
  654.       INCLUDE 'dparam.for'
  655. C
  656.       FINDXT=.TRUE.                             ! assume wins.
  657.       XI=REXIT(RM)                              ! find first entry.
  658.       IF(XI.EQ.0) GO TO 1000                    ! no exits?
  659. C
  660. 100   I=TRAVEL(XI)                              ! get entry.
  661.       XROOM1=I.AND.XRMASK                       ! isolate room.
  662.       XTYPE=(((I.AND..NOT.XLFLAG)/XFSHFT).AND.XFMASK)+1
  663.       GO TO (110,120,130,130),XTYPE             ! branch on entry.
  664.       CALL BUG(10,XTYPE)
  665. C
  666. 130   XOBJ=TRAVEL(XI+2).AND.XRMASK              ! door/cexit- get obj/flag.
  667.       XACTIO=TRAVEL(XI+2)/XASHFT
  668. 120   XSTRNG=TRAVEL(XI+1)                       ! door/cexit/nexit - string.
  669. 110   XI=XI+XELNT(XTYPE)                        ! advance to next entry.
  670.       IF((I.AND.XDMASK).EQ.DIR) RETURN          ! match?
  671.       IF((I.AND.XLFLAG).EQ.0) GO TO 100         ! last entry?
  672. 1000  FINDXT=.FALSE.                            ! yes, lose.
  673.       RETURN
  674. C
  675.       END
  676.  
  677. C FWIM- Find what I mean
  678. C
  679. C Declarations
  680. C
  681.       INTEGER FUNCTION FWIM(F1,F2,RM,CON,ADV,NOCARE)
  682.       IMPLICIT INTEGER (A-Z)
  683.       INCLUDE 'dparam.for'
  684.       LOGICAL NOCARE,QHERE
  685. C
  686.       FWIM=0                                    ! assume nothing.
  687.       DO 1000 I=1,OLNT                          ! loop
  688.         IF(((RM.EQ.0).OR.(.NOT.QHERE(I,RM))) .AND.
  689.      1((ADV.EQ.0).OR.(OADV(I).NE.ADV)) .AND.
  690.      2((CON.EQ.0).OR.(OCAN(I).NE.CON)))
  691.      3GO TO 1000
  692. C
  693. C Object is on list... is it a match?
  694. C
  695.         IF((OFLAG1(I).AND.VISIBT).EQ.0) GO TO 1000
  696.         IF((.NOT.NOCARE .AND.((OFLAG1(I).AND.TAKEBT).EQ.0)) .OR.
  697.      1(((OFLAG1(I).AND.F1).EQ.0).AND.
  698.      2 ((OFLAG2(I).AND.F2).EQ.0))) GO TO 500
  699.         IF(FWIM.EQ.0) GO TO 400                 ! already got something?
  700.         FWIM=-FWIM                              ! yes, ambiguous.
  701.         RETURN
  702. C
  703. 400     FWIM=I                                  ! note match.
  704. C
  705. C Does object contain a match?
  706. C
  707. 500     IF((OFLAG2(I).AND.OPENBT).EQ.0) GO TO 1000 ! closed?
  708.         DO 700 J=1,OLNT                         ! no, search contents.
  709.           IF((OCAN(J).NE.I).OR.((OFLAG1(J).AND.VISIBT).EQ.0) .OR.
  710.      1(((OFLAG1(J).AND.F1).EQ.0).AND.
  711.      2 ((OFLAG2(J).AND.F2).EQ.0))) GO TO 700
  712.           IF(FWIM.EQ.0) GO TO 600
  713.           FWIM=-FWIM
  714.           RETURN
  715. C
  716. 600       FWIM=J
  717. 700     CONTINUE
  718. 1000  CONTINUE
  719.       RETURN
  720. C
  721.       END
  722.  
  723. C ORPHAN- Set up orphans for parser
  724. C
  725. C Declarations
  726. C
  727.       SUBROUTINE ORPHAN(OR1,OR2,OR3,OR4,OR5,OR6,OR7,OR8)
  728.       IMPLICIT INTEGER (A-Z)
  729.       INCLUDE 'dparam.for'
  730.       CHARACTER*(*) OR6
  731. C
  732.       OFLAG=OR1
  733.       OACT=OR2
  734.       OPREP1=OR3
  735.       OOBJ1=OR4
  736.       OPREP=OR5
  737.       ONAME=OR6
  738.       OPREP2=OR7
  739.       OOBJ2=OR8
  740.       RETURN
  741. C
  742.       END
  743.  
  744. C YESNO- Obtain yes/no answer
  745. C
  746. C Called by-
  747. C
  748. C       YES-IS-TRUE=YESNO(QUESTION,YES-STRING,NO-STRING)
  749. C
  750.       LOGICAL FUNCTION YESNO(Q,Y,N)
  751.       IMPLICIT INTEGER (A-Z)
  752.       INCLUDE 'dparam.for'
  753.       CHARACTER*1 ANS
  754. C
  755. 100   CALL RSPEAK(Q)                            ! ask
  756.       READ(INPCH,110,END=120) ANS               ! get answer
  757. 110   FORMAT(A)
  758.       IF((ANS.EQ.'Y').OR.(ANS.EQ.'y')) GO TO 200
  759.       IF((ANS.EQ.'N').OR.(ANS.EQ.'n')) GO TO 300
  760. 120   CALL RSPEAK(6)                            ! scold.
  761.       GO TO 100
  762. C
  763. 200   YESNO=.TRUE.                              ! yes,
  764.       CALL RSPEAK(Y)                            ! out with it.
  765.       RETURN
  766. C
  767. 300   YESNO=.FALSE.                             ! no,
  768.       CALL RSPEAK(N)                            ! likewise.
  769.       RETURN
  770. C
  771.       END
  772.  
  773. C ROBADV-- Steal winner's valuables
  774. C
  775. C Declarations
  776. C
  777.       INTEGER FUNCTION ROBADV(ADV,NR,NC,NA)
  778.       IMPLICIT INTEGER (A-Z)
  779.       INCLUDE 'dparam.for'
  780. C
  781.       ROBADV=0                                  ! count objects
  782.       DO 100 I=1,OLNT
  783.         IF((OADV(I).NE.ADV).OR.(OTVAL(I).LE.0).OR.
  784.      1((OFLAG2(I).AND.SCRDBT).NE.0)) GO TO 100
  785.         CALL NEWSTA(I,0,NR,NC,NA)               ! steal object
  786.         ROBADV=ROBADV+1
  787. 100   CONTINUE
  788.       RETURN
  789. C
  790.       END
  791.  
  792. C ROBRM-- Steal room valuables
  793. C
  794. C Declarations
  795. C
  796.       INTEGER FUNCTION ROBRM(RM,PR,NR,NC,NA)
  797.       IMPLICIT INTEGER (A-Z)
  798.       INCLUDE 'dparam.for'
  799.       LOGICAL PROB,QHERE
  800. C
  801.       ROBRM=0                                   ! count objects
  802.       DO 100 I=1,OLNT                           ! loop on objects.
  803.         IF(.NOT. QHERE(I,RM)) GO TO 100
  804.         IF((OTVAL(I).LE.0).OR.((OFLAG2(I).AND.SCRDBT).NE.0).OR.
  805.      1((OFLAG1(I).AND.VISIBT).EQ.0).OR.(.NOT.PROB(PR,PR)))
  806.      2GO TO 50
  807.         CALL NEWSTA(I,0,NR,NC,NA)
  808.         ROBRM=ROBRM+1
  809.         OFLAG2(I)=OFLAG2(I).OR.TCHBT
  810.         GO TO 100
  811. 50      IF((OFLAG2(I).AND.ACTRBT).NE.0)
  812.      1ROBRM=ROBRM+ROBADV(OACTOR(I),NR,NC,NA)
  813. 100   CONTINUE
  814.       RETURN
  815. C
  816.       END
  817.  
  818. C WINNIN-- See if villain is winning
  819. C
  820. C Declarations
  821. C
  822.       LOGICAL FUNCTION WINNIN(VL,HR)
  823.       IMPLICIT INTEGER (A-Z)
  824.       INCLUDE 'dparam.for'
  825.       LOGICAL PROB
  826. C
  827.       VS=OCAPAC(VL)                             ! villain strength
  828.       PS=VS-FIGHTS(HR,.TRUE.)                   ! his margin over hero
  829.       WINNIN=PROB(90,100)
  830.       IF(PS.GT.3) RETURN                        ! +3... 90% winning
  831.       WINNIN=PROB(75,85)
  832.       IF(PS.GT.0) RETURN                        ! >0... 75% winning
  833.       WINNIN=PROB(50,30)
  834.       IF(PS.EQ.0) RETURN                        ! =0... 50% winning
  835.       WINNIN=PROB(25,25)
  836.       IF(VS.GT.1) RETURN                        ! any villain strength.
  837.       WINNIN=PROB(10,0)
  838.       RETURN
  839. C
  840.       END
  841.  
  842. C FIGHTS-- Compute fight strength
  843. C
  844. C Declarations
  845. C
  846.       INTEGER FUNCTION FIGHTS(H,FLG)
  847.       IMPLICIT INTEGER (A-Z)
  848.       INCLUDE 'dparam.for'
  849.       PARAMETER (STRMAX=7)
  850.       PARAMETER (STRMIN=2)
  851.       LOGICAL FLG
  852. C
  853.       FIGHTS=STRMIN+((((STRMAX-STRMIN)*ASCORE(H))+(MXSCOR/2))/MXSCOR)
  854.       IF(FLG) FIGHTS=FIGHTS+ASTREN(H)
  855.       RETURN
  856. C
  857.       END
  858.  
  859. C VILSTR-       Compute villain strength
  860. C
  861. C Declarations
  862. C
  863.       INTEGER FUNCTION VILSTR(V)
  864.       IMPLICIT INTEGER (A-Z)
  865.       INCLUDE 'dparam.for'
  866. C
  867.       VILSTR=OCAPAC(V)
  868.       IF(VILSTR.LE.0) RETURN
  869.       IF((V.NE.THIEF).OR..NOT.THFENF) GO TO 100
  870.       THFENF=.FALSE.                            ! thief unengrossed.
  871.       VILSTR=MIN0(VILSTR,2)                     ! no better than 2.
  872. C
  873. 100   DO 200 I=1,VLNT                           ! see if best weapon.
  874.         IF((VILLNS(I).EQ.V).AND.(PRSI.EQ.VBEST(I)))
  875.      1VILSTR=MAX0(1,VILSTR-1)
  876. 200   CONTINUE
  877.       RETURN
  878. C
  879.       END
  880.  
  881. C GTTIME-- Get total time played
  882. C
  883. C Declarations
  884. C
  885.       SUBROUTINE GTTIME(T)
  886.       IMPLICIT INTEGER (A-Z)
  887.       INCLUDE 'dparam.for'
  888. C
  889.       CALL ITIME(H,M,S)
  890.       T=((H*60)+M)-((SHOUR*60)+SMIN)
  891.       IF(T.LT.0) T=T+1440
  892.       T=T+PLTIME
  893.       RETURN
  894. C
  895.       END
  896.  
  897. C OPNCLS-- Process open/close for doors
  898. C
  899. C Declarations
  900. C
  901.       LOGICAL FUNCTION OPNCLS(OBJ,SO,SC)
  902.       IMPLICIT INTEGER (A-Z)
  903.       INCLUDE 'dparam.for'
  904.       LOGICAL QOPEN
  905. C
  906. C Functions and data
  907. C
  908.       QOPEN(O)=(OFLAG2(O).AND.OPENBT).NE.0
  909. C
  910.       OPNCLS=.TRUE.                             ! assume wins.
  911.       IF(PRSA.EQ.CLOSEW) GO TO 100              ! close?
  912.       IF(PRSA.EQ.OPENW) GO TO 50                ! open?
  913.       OPNCLS=.FALSE.                            ! lose
  914.       RETURN
  915. C
  916. 50    IF(QOPEN(OBJ)) GO TO 200                  ! open... is it?
  917.       CALL RSPEAK(SO)
  918.       OFLAG2(OBJ)=OFLAG2(OBJ).OR.OPENBT
  919.       RETURN
  920. C
  921. 100   IF(.NOT.QOPEN(OBJ)) GO TO 200             ! close... is it?
  922.       CALL RSPEAK(SC)
  923.       OFLAG2(OBJ)=OFLAG2(OBJ).AND..NOT.OPENBT
  924.       RETURN
  925. C
  926. 200   CALL RSPEAK(125+RND(3))                   ! dummy.
  927.       RETURN
  928. C
  929.       END
  930.  
  931. C LIT-- Is room lit?
  932. C
  933. C Declarations
  934. C
  935.       LOGICAL FUNCTION LIT(RM)
  936.       IMPLICIT INTEGER (A-Z)
  937.       INCLUDE 'dparam.for'
  938.       LOGICAL QHERE
  939. C
  940.       LIT=.TRUE.                                ! assume wins
  941.       IF(DEADF.OR.((RFLAG(RM).AND.RLIGHT).NE.0)) RETURN ! room lit?
  942. C
  943.       DO 1000 I=1,OLNT                          ! look for lit obj
  944.         IF(QHERE(I,RM)) GO TO 100               ! in room?
  945.         OA=OADV(I)                              ! no
  946.         IF(OA.LE.0) GO TO 1000                  ! on adv?
  947.         IF(AROOM(OA).NE.RM) GO TO 1000          ! adv in room?
  948. C
  949. C Obj in room or on adv in room
  950. C
  951. 100     IF((OFLAG1(I).AND.ONBT).NE.0) RETURN    ! lit?
  952.         IF(((OFLAG1(I).AND.VISIBT).EQ.0).OR.
  953.      1(((OFLAG1(I).AND.TRANBT).EQ.0).AND.
  954.      2((OFLAG2(I).AND.OPENBT).EQ.0))) GO TO 1000
  955. C
  956. C Obj is visible and open or transparent
  957. C
  958.         DO 500 J=1,OLNT
  959.           IF((OCAN(J).EQ.I).AND.((OFLAG1(J).AND.ONBT).NE.0))
  960.      1RETURN
  961. 500     CONTINUE
  962. 1000  CONTINUE
  963.       LIT=.FALSE.
  964.       RETURN
  965. C
  966.       END
  967.  
  968. C WEIGHR- Returns sum of weight of qualifying objects
  969. C
  970. C Declarations
  971. C
  972.       INTEGER FUNCTION WEIGHR(CN,AD)
  973.       IMPLICIT INTEGER (A-Z)
  974.       INCLUDE 'dparam.for'
  975.       LOGICAL QHERE
  976. C
  977.       WEIGHR=0
  978.       DO 100 I=1,OLNT                           ! omit big fixed items.
  979.         IF(OSIZE(I).GE.10000) GO TO 100         ! if fixed, forget it.
  980.         IF((OADV(I).EQ.AD).AND.(AD.NE.0)) GO TO 50 ! on adv?
  981.         J=I                                     ! see if contained.
  982. 25      J=OCAN(J)                               ! get next level up.
  983.         IF(J.EQ.0) GO TO 100                    ! end of list?
  984.         IF(((OADV(J).NE.AD).OR.(AD.EQ.0)) .AND.
  985.      1(J.NE.CN)) GO TO 25                       ! cont on adv, or argument?
  986. 50      WEIGHR=WEIGHR+OSIZE(I)                  ! add in weight.
  987. 100   CONTINUE
  988.       RETURN
  989. C
  990.       END
  991.  
  992. C GHERE--       Is global actually in this room?
  993. C
  994. C Declarations
  995. C
  996.       LOGICAL FUNCTION GHERE(OBJ,RM)
  997.       IMPLICIT INTEGER (A-Z)
  998.       INCLUDE 'dparam.for'
  999. C
  1000.       GHERE=.TRUE.                              ! assume wins.
  1001.       IF(OBJ.LE.GLOBAL) RETURN                  ! if untested, return.
  1002.       GO TO (  100,1000,2000,3000,4000,5000,5000,5000,6000,
  1003.      37000,8000,9000,9100,8000,10000,11000,12000,
  1004.      413000,14000,15000),OBJ-GLOBAL
  1005.       CALL BUG(60,OBJ)
  1006. C
  1007. C 100-- Granite Wall
  1008. C
  1009. 100   GHERE=(RM.EQ.TEMP1).OR.(RM.EQ.TREAS).OR.(RM.EQ.SLIDE)
  1010.       RETURN
  1011. C
  1012. C 1000--        House
  1013. C
  1014. 1000  GHERE=((RM.GE.WHOUS).AND.(RM.LE.EHOUS)).OR.
  1015.      1((RM.GE.FORE1).AND.(RM.LE.CLEAR)).OR.(RM.EQ.MTREE)
  1016.       RETURN
  1017. C
  1018. C 2000--        Bird
  1019. C
  1020. 2000  GHERE=((RM.GE.FORE1).AND.(RM.LT.CLEAR)).OR.(RM.EQ.MTREE)
  1021.       RETURN
  1022. C
  1023. C 3000--        Tree
  1024. C
  1025. 3000  GHERE=((RM.GE.FORE1).AND.(RM.LT.CLEAR)).AND.(RM.NE.FORE3)
  1026.       RETURN
  1027. C
  1028. C 4000--        North wall
  1029. C
  1030. 4000  GHERE=((RM.GE.BKVW).AND.(RM.LE.BKBOX)).OR.(RM.EQ.CPUZZ)
  1031.       RETURN
  1032. C
  1033. C 5000--        East, south, west walls
  1034. C
  1035. 5000  GHERE=((RM.GE.BKVW).AND.(RM.LT.BKBOX)).OR.(RM.EQ.CPUZZ)
  1036.       RETURN
  1037. C
  1038. C 6000--        Global water
  1039. C
  1040. 6000  GHERE=(RFLAG(RM).AND.(RWATER+RFILL)).NE.0
  1041.       RETURN
  1042. C
  1043. C 7000--        Global guardians
  1044. C
  1045. 7000  GHERE=((RM.GE.MRC).AND.(RM.LE.MRD)).OR.
  1046.      1((RM.GE.MRCE).AND.(RM.LE.MRDW)).OR.(RM.EQ.INMIR)
  1047.       RETURN
  1048. C
  1049. C 8000--        Rose/channel
  1050. C
  1051. 8000  GHERE=((RM.GE.MRA).AND.(RM.LE.MRD)).OR.(RM.EQ.INMIR)
  1052.       RETURN
  1053. C
  1054. C 9000--        Mirror
  1055. C 9100          Panel
  1056. C
  1057. 9100  IF(RM.EQ.FDOOR) RETURN                    ! panel at fdoor.
  1058. 9000  GHERE=((RM.GE.MRA).AND.(RM.LE.MRC)).OR.
  1059.      1((RM.GE.MRAE).AND.(RM.LE.MRCW))
  1060.       RETURN
  1061. C
  1062. C 10000--       Master
  1063. C
  1064. 10000 GHERE=(RM.EQ.FDOOR).OR.(RM.EQ.NCORR).OR.(RM.EQ.PARAP).OR.
  1065.      1(RM.EQ.CELL).OR.(RM.EQ.PCELL).OR.(RM.EQ.NCELL)
  1066.       RETURN
  1067. C
  1068. C 11000--       Ladder
  1069. C
  1070. 11000 GHERE=(RM.EQ.CPUZZ)
  1071.       RETURN
  1072. C
  1073. C 12000--       Well
  1074. C
  1075. 12000 GHERE=(RM.EQ.TWELL).OR.(RM.EQ.BWELL)
  1076.       RETURN
  1077. C
  1078. C 13000--       Rope in slide
  1079. C
  1080. 13000 GHERE=(RM.GE.SLID1).AND.(RM.LE.SLEDG)
  1081.       RETURN
  1082. C
  1083. C 14000--       Slide
  1084. C
  1085. 14000 GHERE=(RM.GE.SLIDE).OR.((RM.GE.SLID1).AND.(RM.LE.SLEDG))
  1086.       RETURN
  1087. C
  1088. C 15000--       Bunch pseudo object
  1089. C
  1090. 15000 GHERE=.FALSE.                     ! never present
  1091.       RETURN
  1092. C
  1093.       END
  1094.  
  1095. C MRHERE--      Is mirror here?
  1096. C
  1097. C Declarations
  1098. C
  1099.       INTEGER FUNCTION MRHERE(RM)
  1100.       IMPLICIT INTEGER (A-Z)
  1101.       INCLUDE 'dparam.for'
  1102. C
  1103.       IF((RM.LT.MRAE).OR.(RM.GT.MRDW)) GO TO 100
  1104. C
  1105. C Room is an e-w room, mirror must be n-s (mdir= 0 or 180)
  1106. C
  1107.       MRHERE=1                                  ! assume mirror 1 here.
  1108.       IF(MOD(RM-MRAE,2).EQ.(MDIR/180)) MRHERE=2
  1109.       RETURN
  1110. C
  1111. C Room is north or south of mirror.  If mirror is n-s or not
  1112. c within one room of room, lose.
  1113. C
  1114. 100   MRHERE=0
  1115.       IF((IABS(MLOC-RM).NE.1).OR.(MOD(MDIR,180).EQ.0)) RETURN
  1116. C
  1117. C Room is within one of mloc, and mdir is e-w
  1118. C
  1119.       MRHERE=1
  1120.       IF(((RM.LT.MLOC).AND.(MDIR.LT.180)).OR.
  1121.      1 ((RM.GT.MLOC).AND.(MDIR.GT.180))) MRHERE=2
  1122.       RETURN
  1123. C
  1124.       END
  1125.  
  1126. C ENCRYP--      Encrypt password
  1127. C
  1128. C Declarations
  1129. C
  1130.       SUBROUTINE ENCRYP(INW,OUTW)
  1131.       IMPLICIT INTEGER (A-Z)
  1132.       INCLUDE 'dparam.for'
  1133.       CHARACTER*(WRDLNT) INW,OUTW,KEYW
  1134.       INTEGER UINW(8),UKEYW(8)
  1135.       DATA KEYW/'ECOVXRMS'/
  1136. C
  1137.       ICHARA=ICHAR('A')-1                       ! character base.
  1138.       UINWS=0                                   ! unbiased inw sum.
  1139.       UKEYWS=0                                  ! unbiased keyw sum.
  1140.       J=1                                       ! pointer in keyword.
  1141.       DO 100 I=1,WRDLNT                         ! unbias, compute sums.
  1142.         UKEYW(I)=ICHAR(KEYW(I:I))-ICHARA        ! strip ascii.
  1143.         IF(ICHAR(INW(J:J)).LE.ICHARA) J=1       ! recycle on bad.
  1144.         UINW(I)=ICHAR(INW(J:J))-ICHARA
  1145.         UKEYWS=UKEYWS+UKEYW(I)
  1146.         UINWS=UINWS+UINW(I)
  1147.         J=J+1
  1148. 100   CONTINUE
  1149. C
  1150.       USUM=MOD(UINWS,8)+(8*MOD(UKEYWS,8))       ! compute mask.
  1151.       DO 200 I=1,8
  1152.         J=(UINW(I).XOR.UKEYW(I).XOR.USUM).AND.31
  1153.         USUM=MOD(USUM+1,32)
  1154.         IF(J.GT.26) J=MOD(J,26)
  1155.         OUTW(I:I)=CHAR(MAX0(1,J)+ICHARA)
  1156. 200   CONTINUE
  1157.       RETURN
  1158. C
  1159.       END
  1160.  
  1161. C CPGOTO--      Move to next state in puzzle room
  1162. C
  1163. C Declarations
  1164. C
  1165.       SUBROUTINE CPGOTO(ST)
  1166.       IMPLICIT INTEGER (A-Z)
  1167.       INCLUDE 'dparam.for'
  1168. C
  1169.       RFLAG(CPUZZ)=RFLAG(CPUZZ).AND..NOT.RSEEN
  1170.       DO 100 I=1,OLNT                           ! relocate objects.
  1171.         IF((OROOM(I).EQ.CPUZZ).AND.
  1172.      1((OFLAG2(I).AND.(ACTRBT+VILLBT)).EQ.0))
  1173.      2CALL NEWSTA(I,0,CPHERE*HFACTR,0,0)
  1174.         IF(OROOM(I).EQ.(ST*HFACTR))
  1175.      1CALL NEWSTA(I,0,CPUZZ,0,0)
  1176. 100   CONTINUE
  1177.       CPHERE=ST
  1178.       RETURN
  1179. C
  1180.       END
  1181.  
  1182. C CPINFO--      Describe puzzle room
  1183. C
  1184. C Declarations
  1185. C
  1186.       SUBROUTINE CPINFO(RMK,ST)
  1187.       IMPLICIT INTEGER (A-Z)
  1188.       INCLUDE 'dparam.for'
  1189.       INTEGER DGMOFT(8)
  1190.       CHARACTER*2 DGM(8),PICT(5),QMK
  1191. C
  1192. C Functions and local data
  1193. C
  1194.       DATA DGMOFT/-9,-8,-7,-1,1,7,8,9/
  1195.       DATA PICT/'SS','SS','SS','  ','MM'/
  1196.       DATA QMK/'??'/
  1197. C
  1198.       CALL RSPEAK(RMK)
  1199.       DO 100 I=1,8
  1200.         J=DGMOFT(I)
  1201.         DGM(I)=PICT(CPVEC(ST+J)+4)              ! get picture element.
  1202.         IF((IABS(J).EQ.1).OR.(IABS(J).EQ.8)) GO TO 100
  1203.         K=8
  1204.         IF(J.LT.0) K=-8                         ! get ortho dir.
  1205.         L=J-K
  1206.         IF((CPVEC(ST+K).NE.0).AND.(CPVEC(ST+L).NE.0))
  1207.      1DGM(I)=QMK
  1208. 100   CONTINUE
  1209.       WRITE(OUTCH,10) DGM
  1210. C
  1211.       IF(ST.EQ.10) CALL RSPEAK(870)             ! at hole?
  1212.       IF(ST.EQ.37) CALL RSPEAK(871)             ! at niche?
  1213.       I=872                                     ! door open?
  1214.       IF(CPOUTF) I=873
  1215.       IF(ST.EQ.52) CALL RSPEAK(I)               ! at door?
  1216.       IF(CPVEC(ST+1).EQ.-2) CALL RSPEAK(874)    ! east ladder?
  1217.       IF(CPVEC(ST-1).EQ.-3) CALL RSPEAK(875)    ! west ladder?
  1218.       RETURN
  1219. C
  1220. 10    FORMAT('       |',A,1X,A,1X,A,'|'/,
  1221.      1' West  |',A,' .. ',A,'|  East'/,
  1222.      2'       |',A,1X,A,1X,A,'|')
  1223. C
  1224.       END
  1225.  
  1226. C NBLEN-        Compute string length without trailing blanks
  1227. C
  1228. C Declarations
  1229. C
  1230.       INTEGER FUNCTION NBLEN(STRING)
  1231.       IMPLICIT INTEGER (A-Z)
  1232.       CHARACTER*(*) STRING
  1233. C
  1234.       NBLEN=LEN(STRING)                         ! get nominal length
  1235. 100   IF(NBLEN.LE.0) RETURN                     ! any string left?
  1236.       IF(STRING(NBLEN:NBLEN).NE.' ') RETURN     ! found a non-blank?
  1237.       NBLEN=NBLEN-1                             ! no, trim len by 1
  1238.       GO TO 100                                 ! and continue.
  1239. C
  1240.       END
  1241.  
  1242. C
  1243. C RND - Return a random integer mod n
  1244. C
  1245.       INTEGER FUNCTION RND (N)
  1246.       IMPLICIT INTEGER (A-Z)
  1247.       REAL R
  1248.  
  1249.       CALL RANDOM(R)
  1250.       RND = R*FLOAT(N)
  1251.       RETURN
  1252.  
  1253.       END
  1254. C
  1255. C INIRND - Initialize random number seed
  1256. C
  1257.       SUBROUTINE INIRND (LOW, HIGH)
  1258.       IMPLICIT INTEGER (A-Z)
  1259.  
  1260.       CALL SEED((ISHFT(HIGH,16)+LOW).OR.1)
  1261.       RETURN
  1262.  
  1263.       END
  1264.